-- -*- haskell -*-
{-# OPTIONS -XBangPatterns -fglasgow-exts -funbox-strict-fields -O2 -optc-O3 #-}
{-

-- WAM Engine
--  This is very much based on ait-Kaci's book, WAM, a Tutorial Reconstruction
--  The (signifigant) differences are in randomized predicates.  In a randomized
--  predicate:  
--    -- On a call, a collection of "try_me" instructions are pushed onto
--       the code, and then jumped to, in a random order
--    -- randomized try_mes and proceeds have implicit jumps inside them
--    -- there's an additonal "random_neck" instruction, which builds a 
--       collection of jumps for each literal in the clause 
--    -- hooks exist for call recording and updating associated map data
--       to modify the weightings for "random_neck" instructions
-}

-- This interface stinks for now, need to get all the ST stuff out of Main



module Engine (execCode,
	       -- execCodeEntryInst,
	       getQueryResult,
	       setQueryResult,
	       allocate,
	       try_here,
	       retry_here,
	       trust_here,
	       put_structure,
	       get_value,
	       resetRegister,
	       resetArgRegister,
	       newArgRegister,
	       newTempRegister,
	       setTopTempRegister,
	       getTopArgRegister,
	       emptyVMap,
	       insertVMap,
	       getVMap,
	       pushCode,
	       setCode,
	       dumpCode,
	       insertCallIndex,
	       Engine.newAtom,
	       Engine.lookupAtom,
	       dd,
	       ddout,
	       dh,
	       getHEntry,
	       getRegister,
	       getCT,
	       getPC,
	       getBP,
	       getDedBP,
	       getChoiceBottom,
	       incPC,
	       setPC,
	       setCT,
	       setOCT,
	       setBP,
	       setChoiceBottom,
	       setDedBP,
	       doWAMFail,
	       deref,
	       deref1,
	       derefdebug,
	       regmap,
	       popCallStackBPNINC,
	       popCallStackBPINC,
	       popCallStackNull,
	       callRandList,
	       callList,
	       isVar,
	       setRandoms,
	       Engine.updateWeights,
	       Engine.resetTable,
	       cookedTerm,
	       dumpCallStack,
	       setDepth,
	       setLambda,
	       setScale,
	       replacePointChange,
               newWAMData,
               newICData,
               getGlobalCount,
               zeroDeductiveCount,
               zeroInductiveCount,
               getDeductiveCount,
               getInductiveCount
	      )
    where

import RPTypes
import EngineTypes
import TableAccounting
import AtomMap

import Prelude hiding (lookup)
import IO
-- import Control.Monad.BackT
import Data.Ix
import Control.Monad
import Data.Array.IO 
import Data.Array.Base
import Data.IORef
import Data.Map (Map,empty,lookup,insert,fromList,elems,assocs)
import Data.List hiding (lookup,insert)
import Control.Monad.State
import Maybe
import System.Random
import Data.Word

import GHC.Exts

-- import Debug.Trace.Location

import SParser (stringToTerm)

import System.IO.Unsafe
import System.Exit

import qualified Data.Set as Set

import Foreign.Ptr
import Foreign.C.Types
import C2HS


-- import HistTree (findWithDefault,showTree)

--
-- We have a SLD monad, which contains the current goals
--   The operations are:
--  select: SLD Goal
--  unifyclause: SLD Goal -> Clause -> SLD ()
--  bindings: Variable -> Term
--  isGoalsLeft: Bool
--
-- It will contain a WAM monad which is a state machine with the various WAM 
-- operations

-- type SLD = BackT GoalSet

-- type WAM a = IO (WAMData a)

--
-- BASIC OPERATIONS
-- Interface to underlying WAM representation
--

-- Int is the heapsize

--
-- Heap grows up from 0, environment grows down from top of heap

-- chs stuff up the top

foreign export ccall "haskell_exit" exitFailure :: IO ()

#c
#include <stdint.h>
#endc

newWAMData:: IO PWAMData
newWAMData = return {# call pure newWAMData_c #}
#c
struct WAMData *newWAMData_c();
#endc

newICData:: IO PICCount
newICData = return {# call pure newICCount_c #}
#c
struct ICCount *newICCount_c();
#endc

{# fun getDeductiveCount {id `PICCount'} -> `Counter' cIntConv #}
#c
uint64_t getDeductiveCount(struct ICCount *i);
#endc
{# fun getInductiveCount {id `PICCount'} -> `Counter' cIntConv #}
#c
uint64_t getInductiveCount(struct ICCount *i);
#endc
{# fun getGlobalCount {id `PICCount'} -> `Counter' cIntConv #}
#c
uint64_t getGlobalCount(struct ICCount *i);
#endc

{# fun incICCount {id `PICCount'} -> `()' #}
#c
void incICCount (struct ICCount *i);
#endc

incCallCount :: (WAMData a) -> IO ()
incCallCount wd = incICCount (cCallCount wd)

incInstCount :: (WAMData a) -> IO ()
incInstCount wd = incICCount (cInstCount wd)

{# fun zeroICCount {id `PICCount'} -> `()' #}
#c
void zeroICCount (struct ICCount *i);
#endc
zeroCounts :: (WAMData a) -> IO ()
zeroCounts wd = do zeroICCount (cCallCount wd)
                   zeroICCount (cInstCount wd)

{# fun zeroICDeductiveCount {id `PICCount'} -> `()' #}
#c
void zeroICDeductiveCount(struct ICCount *i);
#endc
zeroDeductiveCount :: (WAMData a) -> IO ()
zeroDeductiveCount wd = do zeroICDeductiveCount (cCallCount wd)
                           zeroICDeductiveCount (cInstCount wd)

{# fun zeroICInductiveCount {id `PICCount'} -> `()' #}
#c
void zeroICInductiveCount(struct ICCount *i);
#endc
zeroInductiveCount :: (WAMData a) -> IO ()
zeroInductiveCount wd = do zeroICInductiveCount (cCallCount wd)
                           zeroICInductiveCount (cInstCount wd)

push :: (WAMData a)-> HEntry -> IO WAMRef
push wd op = 
       do t <- getHT wd
          writeArray (heap wd) t op
          incHT wd 1
          return t

getCT :: (WAMData a) -> IO WAMRef
getCT wd = 
    do val <- readIORef $ codeTop wd
       -- dd ("GETTING CT; VALUE :" ++ (show val) ++ "\n")
       return val

getOCT :: (WAMData a) -> IO WAMRef
getOCT wd = 
    do val <- readIORef $ oldCodeTop wd
       -- dd ("GETTING OCT; VALUE :" ++ (show val) ++ "\n")
       return val

getTT :: (WAMData a) -> IO TrailRef
getTT wd = readIORef $ trailTop wd

getPC :: (WAMData a) -> IO WAMRef
getPC wd = readIORef $ pc wd

getCP :: (WAMData a) -> IO WAMRef
getCP wd = readIORef $ contp wd

getEP :: (WAMData a) -> IO WAMRef
getEP wd = readIORef $ envTop wd

getSR :: (WAMData a) -> IO WAMRef
getSR wd = readIORef $ sreg wd

getHT :: (WAMData a) -> IO WAMRef
getHT wd = 
        do t <- readIORef $ heapTop wd
           return t
           
getChoiceBottom :: (WAMData a) -> IO WAMRef
getChoiceBottom wd = readIORef $ choiceBottom wd

setChoiceBottom :: (WAMData a) -> WAMRef -> IO ()
setChoiceBottom wd ref = writeIORef (choiceBottom wd) ref

noCP :: (WAMData a) -> IO Bool
noCP wd = 
    do stacksize <- getChoiceBottom wd
       b <- getBP wd
       return (b >= stacksize) 

-- getHB looks for this in the previous choice point
getHB wd =
    do b <- getBP wd
       nochoice <- noCP wd
       if nochoice   -- no choice points present
         then return 0
         else do ob <- getHEntry wd (b + oChoicep)
                 if (isHRef ob)
		    then return (getHRef ob)
		    else fail "NON_REFERENCE IN OLD CHOICE POINTER"

getDedBP :: (WAMData a) -> IO WAMRef
getDedBP wd = 
        do t <- readIORef $ dedchoice wd
           return t


getBP :: (WAMData a) -> IO WAMRef
getBP wd = 
        do t <- readIORef $ choice wd
           return t
           
getB0P :: (WAMData a) -> IO WAMRef
getB0P wd = 
        do t <- readIORef $ cutchoice wd
           return t

getRands :: (WAMData a) -> Int -> IO [Double]
getRands wd k =
    do {rng <- readIORef $ sgen wd;
       let (g,i) = (kth genaccum (rng,[]) k)
       in do {writeIORef (sgen wd) g;
              return i}}

-- iterate kills the garbage collector
kth _ r 0 = r
kth f r n = kth f (f r) (n - 1)

genaccum :: (StdGen,[Double]) -> (StdGen,[Double])
genaccum (gen,ints) =
	let (i,g) = System.Random.random gen
	in (g,i:ints)

setPC :: (WAMData a) -> WAMRef -> IO ()
setPC wd ref = writeIORef (pc wd) ref

setCT:: (WAMData a) -> WAMRef -> IO ()
setCT wd ref =
    do dd ("SETTING CT; VAL IS: " ++ (show ref) ++ "\n")
       writeIORef (codeTop wd) ref

setOCT:: (WAMData a) -> WAMRef -> IO ()
setOCT wd ref = 
    do dd ("SETTING OCT; VAL IS: " ++ (show ref) ++ "\n")
       writeIORef (oldCodeTop wd) ref

setSR:: (WAMData a) -> WAMRef -> IO ()
setSR wd ref = writeIORef (sreg wd) ref

setCP:: (WAMData a) -> WAMRef -> IO ()
setCP wd ref = writeIORef (contp wd) ref

setEP :: (WAMData a) -> WAMRef -> IO ()
setEP wd ref = writeIORef (envTop wd) ref

setHT :: (WAMData a) -> WAMRef -> IO ()
setHT wd ref = writeIORef (heapTop wd) ref

setBP :: (WAMData a) -> WAMRef -> IO ()
setBP wd ref = 
    writeIORef (choice wd) ref

setB0P :: (WAMData a) -> WAMRef -> IO ()
setB0P wd ref = writeIORef (cutchoice wd) ref

setDedBP :: (WAMData a) -> WAMRef -> IO ()
setDedBP wd ref = writeIORef (dedchoice wd) ref

setTT :: (WAMData a) -> TrailRef -> IO ()
setTT wd ref = writeIORef (trailTop wd) ref

setQueryResult wd val = writeIORef (queryResult wd) val
getQueryResult wd  = readIORef (queryResult wd) 

getQueryResultptr :: StablePtr (WAMData a) -> IO CInt
getQueryResultptr pwd = 
        do wd <- deRefStablePtr pwd
           res <- getQueryResult wd
           return (fromBool res)

foreign export ccall "getQueryResult" getQueryResultptr :: StablePtr (WAMData a) -> IO CInt

incHT :: (WAMData a) -> UnsignedNum -> IO WAMRef
incHT wd inc = 
     let hinc = ( inc)
     in do t <- readIORef $ heapTop wd
           if (t + hinc) > heapSize wd
             then fail "Exceeded maximum heap size"
             else do writeIORef (heapTop wd) (t + hinc)
                     return t

{-# INLINE incPC #-}

incPC :: (WAMData a) -> IO WAMRef
incPC wd = 
        do t <- readIORef $ pc wd
           -- dd ("Program counter is " ++ (show t) ++"\n")
           (writeIORef (pc wd)) $! (t + 1)
           return $! (t + 1)

incPCptr :: StablePtr (WAMData a) -> IO ()
incPCptr pwd = 
        do wd <- deRefStablePtr pwd
           incPC wd
           return ()

foreign export ccall "incPC" incPCptr :: StablePtr (WAMData a) -> IO ()

incET :: (WAMData a) -> UnsignedNum -> IO WAMRef
incET wd inc = 
     let einc = ( inc)
     in do t <- readIORef $ envTop wd
           writeIORef (envTop wd) (t - einc)
           return (t - einc)
{-
incCT :: (WAMData a) -> Int -> IO WAMRef
incCT wd inc = 
     let cinc = ( inc)
     in do t <- readIORef $ codeTop wd
           writeIORef (codeTop wd) (t + cinc)
           return (t + cinc)
-}

{-# INLINE getHEntry #-}
getHEntry :: (WAMData a) -> WAMRef -> IO HEntry
getHEntry !wd !ref = unsafeRead (heap wd) ref

{-# INLINE getCodeEntry #-}
getCodeEntry :: (WAMData a) -> IO (WAMOpRaw, WAMOpRaw)
getCodeEntry wd = 
                  do ix <- readIORef $ pc wd
                     val1 <- readArray (code wd) ix
		     val2 <- readArray (codeaux wd) ix
		     return (val1, val2)

{-# INLINE getCodeEntryInst #-}
getCodeEntryInst :: (WAMData a) -> IO (WAMOpRaw)
getCodeEntryInst wd = 
                  do ix <- readIORef $ pc wd
                     val1 <- unsafeRead (code wd) ix
		     return (val1)

{-# INLINE getCodeEntryAux #-}
getCodeEntryAux :: (WAMData a) -> IO (WAMOpRaw)
getCodeEntryAux wd = 
                  do ix <- readIORef $ pc wd
                     val1 <- unsafeRead (codeaux wd) ix
		     return (val1)

foreign export ccall "getCodeEntryInst" getCodeEntryInstptr :: StablePtr (WAMData a) -> IO WAMOpRawExternal

getCodeEntryInstptr :: StablePtr (WAMData a) -> IO WAMOpRawExternal
getCodeEntryInstptr pwd = do wd <- deRefStablePtr pwd
                             res <- getCodeEntryInst wd 
                             return (fromIntegral res)

foreign export ccall "getCodeEntryAux" getCodeEntryAuxptr :: StablePtr (WAMData a) -> IO WAMOpRawExternal

getCodeEntryAuxptr :: StablePtr (WAMData a) -> IO WAMOpRawExternal
getCodeEntryAuxptr pwd = do wd <- deRefStablePtr pwd
                            res <- getCodeEntryAux wd
                            return (fromIntegral res)


getCodeEntryAt :: (WAMData a) -> WAMRef -> IO (WAMOpRaw,WAMOpRaw)
getCodeEntryAt wd ix =
    do val1 <- readArray (code wd) ix
       val2 <- readArray (codeaux wd) ix
       return (val1, val2)

{-# INLINE setHEntry #-}
setHEntry :: (WAMData a) -> WAMRef -> HEntry -> IO ()
setHEntry !wd !ref !ent = 
       unsafeWrite (heap wd) ref ent
                   
isRef :: (WAMData a) -> WAMRef -> IO Bool
isRef wd ref = do inst <- getHEntry wd ref
                  return (isHRef inst)

deref :: (WAMData a) -> WAMRef -> IO WAMRef
deref wd ref = 
	do val <- readArray (heap wd) ref
	   --case val of
	   --  (HRef newref) -> if ref == newref
	   --                      then return ref
	   --                      else deref wd newref
	   --  otherwise -> return ref
	   if (isHRef val)
	      then if ref == (getHRef val)
		      then return ref
		      else deref wd (getHRef val)
	      else return ref


setVar :: (WAMData a) -> WAMRef -> WAMRef -> IO ()
setVar wd from to
              = do writeArray (heap wd) from (buildHRef to)
                   return ()

pushVariable wd = do ref <- getHT wd
                     set_variable' wd ref
                     incHT wd 1
                     return ref 

emptyVMap :: (WAMData a) -> IO ()
emptyVMap wd = writeIORef (variableMap wd) Data.Map.empty

getVMap :: (WAMData a) -> Variable -> IO (Maybe Register)
getVMap wd v = 
        do fm <- readIORef $ variableMap wd 
           dd ("varaiablemap is " ++ (foldl (++) "" (Prelude.map show (Data.Map.assocs fm))) ++ "\n")
           return (lookup v fm)

insertVMap ::(WAMData a) -> Variable -> Register -> IO ()
insertVMap wd v r 
          = do fm <- readIORef fm0
               dd ("Inserting " ++ v ++ " -> " ++ (show r) ++ "\n")
               writeIORef fm0 (insert v r fm)
               return ()
    where fm0 = variableMap wd

newAtom :: (WAMData a) -> Atom -> IO AtomRef
newAtom wd str =
    do {am <- readIORef $ atomIndex wd;
        let {(key,newam) = (AtomMap.newAtom str am)}
        in do {writeIORef (atomIndex wd) newam;
	       return key}}

lookupAtom :: (WAMData a) -> AtomRef -> IO (Maybe Atom)
lookupAtom wd key = 
    do am <- readIORef $ atomIndex wd
       return (AtomMap.lookupAtom key am)


newClauseID :: (WAMData a) -> ClauseID -> IO ClauseIDRef
newClauseID wd cid =
    do {am <- readIORef $ clauseIDIndex wd;
        let {(key,newam) = (AtomMap.newAtom cid am)}
        in do {writeIORef (clauseIDIndex wd) newam;
	       return key}}

lookupClauseID :: (WAMData a) -> ClauseIDRef -> IO (Maybe ClauseID)
lookupClauseID wd key = 
    do am <- readIORef $ clauseIDIndex wd
       return (AtomMap.lookupAtom key am)

insertCallIndex ::(WAMData a) -> AtomRef -> Arity -> WAMRef -> IO ()
insertCallIndex wd at ar wr 
          = do fm <- readIORef fm0
               writeIORef fm0 (insert (at,ar) wr fm)
               return ()
    where fm0 = callIndex wd

getCallIndex :: (WAMData a) -> AtomRef -> Arity -> IO (Maybe WAMRef)
getCallIndex wd at ar
    = do fm <- readIORef $ callIndex wd
         return (lookup (at,ar) fm)

insertBuiltin ::(WAMData a) -> Atom -> Arity -> (Builtin a) -> IO ()
insertBuiltin wd atstr ar wr 
          = do fm <- readIORef fm0
	       at <- Engine.newAtom wd atstr
               writeIORef fm0 (insert (at,ar) wr fm)
               return ()
    where fm0 = builtinIndex wd

getBuiltin :: (WAMData a) -> AtomRef -> Arity -> IO (Maybe (Builtin a))
getBuiltin wd at ar
    = do fm <- readIORef $ builtinIndex wd
         return (lookup (at,ar) fm)

setWriteMode :: (WAMData a) -> IO ()
setWriteMode wd = 
    do writeIORef (mode wd) Write
       return ()

setReadMode :: (WAMData a) -> IO ()
setReadMode wd = writeIORef (mode wd) Read

isWriteMode :: (WAMData a) -> IO Bool
isWriteMode wd = 
    do val <- readIORef (mode wd)
       return (val == Write)

isReadMode :: (WAMData a) -> IO Bool
isReadMode wd =
    do val <- readIORef (mode wd)
       return (val == Read)

resetArgRegister :: (WAMData a) -> IO ()
resetArgRegister wd = writeIORef (argreg wd) 0

resetRegister :: (WAMData a) -> IO ()
resetRegister wd = do resetArgRegister wd
                      writeIORef (tempreg wd) 0

newTempRegister :: VarMap -> (WAMData a) -> IO Register
newTempRegister vm wd = 
    do reg <- readIORef (tempreg wd)
       writeIORef (tempreg wd) ((assignRegisterH vm reg) + 1)
       return (TempRegister (assignRegisterH vm reg))

-- Big ugly hack
assignRegisterH :: VarMap -> UnsignedNum -> UnsignedNum
assignRegisterH vm m = 
	let used = foldl (\x y -> (x ++ (dereg y))) [] (Data.Map.elems vm)
	    possibles = [ x | x <- [0.. 100], x >= m, not (x `elem` used)]
	in minimum possibles
	where dereg (TempRegister x) = [x]
	      dereg _ = []
    
newArgRegister :: (WAMData a) -> IO Register
newArgRegister wd = 
    do reg <- readIORef (argreg wd)
       writeIORef (argreg wd) (reg + 1)
       -- return ( - reg)
       return (ArgRegister reg)

getTopTempRegister :: (WAMData a) -> IO UnsignedNum
getTopTempRegister wd = 
      do t <- readIORef $ tempreg wd
         return t

setTopTempRegister :: (WAMData a) -> UnsignedNum -> IO ()
setTopTempRegister wd int = writeIORef  (tempreg wd) int

getTopArgRegister :: (WAMData a) -> IO UnsignedNum
getTopArgRegister wd = 
      do t <- readIORef $ argreg wd
         return t

getRegister :: (WAMData a) -> RegisterRaw -> IO HEntry
getRegister !wd !reg = 
    do addr <- regmap wd reg
       getHEntry wd addr

       
setRegister :: (WAMData a) -> RegisterRaw-> HEntry -> IO ()
setRegister !wd !reg !entry =
    do addr <- regmap wd reg
       setHEntry wd addr entry 

{-# INLINE regmap #-}
regmap :: (WAMData a) -> RegisterRaw -> IO WAMRef
regmap !wd !regraw = 
    do ep <- getEP wd
       return (regmap1 (reg_type_bits regraw) ep (reg_id_reverse regraw) (heapSize wd))

{-
null_reg_t = 0x00 :: Word8
arg_reg_t = 0x40 :: Word8
perm_reg_t = 0x80 :: Word8
temp_reg_t = 0xc0 :: Word8
-}


regmap1 0x40 _ !(reg) size = (size + argRegSize - reg)
regmap1 0x80 ep !(reg) _ =  (ep + reg + 3) -- two slots for progref and backpointer ...
regmap1 0xc0 _ !(reg) size = (size + (argRegSize*2) - reg)

{-
zeroCounts :: (WAMData a) -> Int -> IO ()
zeroCounts wd c = do writeArray (instcount wd) c 0
                     writeArray (callcount wd) c 0
         
{-# INLINE incCallCount #-}

incCallCount :: (WAMData a) -> IO ()
incCallCount wd = 
    do cr <- readIORef $ countsRunning wd
       if cr
          then do --mapM (\x -> inccount wd callcount x) [0 .. (countCount - 1)]
		  inccount wd callcount 0
		  inccount wd callcount 1
		  inccount wd callcount 2
                  return ()
	  else return ()

-}

{-
{-# INLINE incInstCount #-}
-- MANUALLY UNWOUND FOR PERFORMANCE
-- CHECK_COUNTS is a performance hack too
incInstCount :: (WAMData a) -> IO ()
incInstCount wd  = 
#ifdef CHECK_COUNTS_RUNNING
    do cr <- readIORef $ countsRunning wd
       if cr
          then 
#endif
               do -- mapM (\x -> inccount wd instcount x) [0 .. countCount]
		  s0 <- unsafeRead (instcount wd) 0
                  unsafeWrite (instcount wd) 0 $! (1+s0)
		  s1 <- unsafeRead (instcount wd) 1
                  unsafeWrite (instcount wd) 1 $! (1+s1)
		  s2 <- unsafeRead (instcount wd) 2
                  unsafeWrite (instcount wd) 2 $! (1+s2)
                  return ()
#ifdef CHECK_COUNTS_RUNNING
	  else return ()
#endif

{-# INLINE inccount #-}

inccount wd count r = do s <- readArray (count wd) r
                         writeArray (count wd) r $! (s+1)

-}

insertCIDIndex wd (Try_here _ _ cid) = icid wd cid
insertCIDIndex wd (Retry_here _ cid) = icid wd cid
insertCIDIndex wd (Trust_here cid) = icid wd cid
insertCIDIndex wd (Try_there _ _ _ cid) = icid wd cid
insertCIDIndex wd (Retry_there _ _ cid) = icid wd cid
insertCIDIndex wd (Trust_there _ cid) = icid wd cid
insertCIDIndex wd (Randomize_trust_there _ cid) = icid wd cid
insertCIDIndex wd (RP_trust_there _ cid) = icid wd cid
insertCIDIndex wd _ = return ()

icid wd cid = do cix <- readIORef $ clauseIDIndex wd
		 writeIORef (clauseIDIndex wd) (snd $ AtomMap.newAtom cid cix)

pushCodeRaw ::  (WAMData a) -> (WAMOpRaw,WAMOpRaw) -> IO ()
pushCodeRaw wd (opinst,opaux) = 
    do t <- readIORef $ codeTop wd
       writeArray (code wd) t opinst
       writeArray (codeaux wd) t (opaux)
       writeIORef (codeTop wd) (t + 1)

pushCode :: (WAMData a) -> WAMOp -> IO WAMRef
pushCode wd op = do t <- readIORef $ codeTop wd
		    insertCIDIndex wd op
		    cix <- readIORef (clauseIDIndex wd)
                    if (t > stacksize)
                       then fail ("Code Overflow, exceeded stack size of " ++ (show stacksize))
                       else return ();
		    let (opinst,opaux) = wAMOpToWAMOpRaw op cix
			in do writeArray (code wd) t opinst
			      writeArray (codeaux wd) t (opaux)
			      writeIORef (codeTop wd) (t + 1)
			      return t

testt x y = do ddout ("X IS: " ++ (show x) ++ " Y IS: " ++ (show y) ++"\n")
	       if x == y then return() else undefined

pushCodeList :: (WAMData a) -> [WAMOp] -> IO ()
pushCodeList wd l = do mapM (pushCode wd) l
                       return ()

pushCodeListRaw :: (WAMData a) -> [(WAMOpRaw,WAMOpRaw)] -> IO ()
pushCodeListRaw wd l = do mapM (pushCodeRaw wd) l
                          return ()


setCode :: (WAMData a) -> WAMRef -> WAMOp -> IO ()
setCode wd ref op = 
    do insertCIDIndex wd op
       cix <- readIORef (clauseIDIndex wd)
       let (opinst,opaux) = wAMOpToWAMOpRaw op cix
	   in do writeArray (code wd) ref opinst
		 writeArray (codeaux wd) ref (opaux)
		 return ()

dumpCallRandStack wd = do cs <- callRandList wd; dd ("CallRandList is: " ++ (show cs) ++ "\n") ; return ()
                       


popCallStack :: (WAMData a) -> IO ClauseIDRef
popCallStack wd = 
              do -- ddout ("POPPING!\n")
                 ((cid,sty,ref):ss) <- readIORef $ callstack wd
                 writeIORef (callstack wd) ss
                 if sty == Trust
                    then popCallStack wd
                    else do dd ("POP DONE\n")
                            return (cid)

popCallStackNull :: (WAMData a) -> IO ()
popCallStackNull wd = 
    let eCID = exceptCID wd
	in do -- ddout ("POPPING NULL!\n")
	     ((cid,_,_):ss) <- readIORef $ callstack wd
	     writeIORef (callstack wd) ss
	     if cid /= eCID
		then popCallStackNull wd
                else do -- dd ("POP DONE\n")
                       return ()



popCallStackBPNINC :: (WAMData a) -> WAMRef -> IO ()
popCallStackBPNINC wd bp = 
    do get <- readIORef $ callstack wd
       if not $ null get
	  then let ((cid,_,cbp):ss) = get
		in if cbp < bp
		      then do writeIORef (callstack wd) ss
			      -- ddout ("POPPING NINC " ++ (show (cid,cbp,bp)) ++ "\n")
			      popCallStackBPNINC wd bp
		      else return ()
	  else return ()


popCallStackBPINC :: (WAMData a) -> WAMRef -> IO ()
popCallStackBPINC wd bp = 
    do get <- readIORef $ callstack wd
       if not $ null get
	  then let ((cid,_,cbp):ss) = get
		in if cbp <= bp
		      then do writeIORef (callstack wd) ss
			      -- ddout ("POPPING INC " ++ (show (cid,cbp,bp)) ++ "\n")
			      if cbp == bp
			        then return ()
			        else popCallStackBPINC wd bp
		      else return ()
	  else return ()

pushCallStack :: (WAMData a) -> ClauseIDRef -> ChoiceStyle -> WAMRef -> IO ()
pushCallStack wd op style ref =
    do ts <- readIORef $ callstack wd
       writeIORef (callstack wd) ((op,style,ref):ts)
       -- ddout ("Pushing: " ++ (show op) ++ "\n")
       return ()
          
setRandoms :: (WAMData a) -> [PredID] -> IO ()
setRandoms wd rs =
    do writeIORef (randpreds wd) (Set.fromList rs)
       return ()

isRandom :: (WAMData a) -> PredID -> IO Bool
isRandom wd pid = 
     do rs <- (readIORef $ randpreds wd)
        return (Set.member pid rs) 

{-
setCallStackTopElem :: (WAMData a) -> ClauseID -> IO CallStackRef
setCallStackTopElem wd op = do t <- readIORef $ callstackTop wd
                               writeArray (callstack wd) (t - 1) op
                               dd ("Writing to CS" ++ (show op) ++ "\n")
                               return t

getCallStack :: (WAMData a) -> CallStackRef -> IO ClauseID
getCallStack wd ref = do cid <- readArray (callstack wd) ref
                         return cid
-}
callList :: (WAMData a) -> IO [CallStackEntry]
callList wd = readIORef $ callstack wd

callRandListCID  :: (WAMData a) -> IO [ClauseID]
callRandListCID wd =
    do crl <- callRandList wd
       cix <- readIORef $ clauseIDIndex wd
       return (map (\x -> fromJust$ AtomMap.lookupAtom x cix) crl)


callRandList :: (WAMData a) -> IO [ClauseIDRef]
callRandList wd = 
	do cl <- callList wd
	   cix <- readIORef $ clauseIDIndex wd
	   rands <- readIORef $ randpreds wd
	   return (fff cix cl rands)

fff cix cl rands = filter (\x -> Set.member (clauseIDRefToPredID x cix) rands) (map (\(x,_,_) -> x) cl) 

clauseIDRefToPredID x cix = clauseIDToPredID (fromJust $ AtomMap.lookupAtom x cix)

entrail :: (WAMData a) -> WAMRef -> IO ()
entrail wd ref = do entry <- getHEntry wd ref
                    ix <- readIORef $ trailTop wd
                    writeArray (trail wd) ix (TE ref entry)
                    writeIORef (trailTop wd) (ix + 1)
		    dd ("WRITING " ++ (show (ix + 1)) ++ " TO TRAIL TOP\n")
                    return ()
                    
detrail :: (WAMData a) -> IO TrailRef
detrail wd  = do ix <- readIORef $ trailTop wd
                 tentry <- readArray (trail wd) (ix - 1)
                 case tentry of
                    (TE ref hentry) -> do setHEntry wd ref hentry
					  dd ("DETRAIL SETTING: " ++ (show ref) ++ " TO " ++ (pentry hentry) ++ "\n")
                                          writeIORef (trailTop wd) (ix - 1)
                                          return (ix - 1)
                    otherwise -> fail "ILLEGAL TRAIL CONTENT\n"

unwind_trail :: (WAMData a) -> TrailRef -> IO ()
unwind_trail wd stopref = 
   do dd "UNWINDING TRAIL\n"
      top <- getTT wd
      dd ("TOP OF TRAIL AT " ++ (show top) ++ "\n")
      if (top == stopref)
        then return ()
        else do detrail wd
                unwind_trail wd stopref


tidy_trail ::(WAMData a) -> IO ()
tidy_trail wd =
  do nochoice <- noCP wd
     bp <- getBP wd
     if not nochoice
        then do tp <- getHEntry wd (bp + oTrail)
                tt1 wd (deref1 tp)
        else return ()

-- XXX BUG IN HERE ---

tt1 wd tp =
    do ttop <- getTT wd
       if tp < ttop
          then do out1 <- (outsideHeapBody wd tp)
                  out2 <- (outsideStackBody wd tp)
                  if not (out1 && out2)
                   then tt1 wd (tp + 1) -- this doesn't need cleaning
                   else do te <- readArray (trail wd) (ttop - 1)
                           writeArray (trail wd) tp te
                           setTT wd (ttop - 1)
                           tt1 wd (tp + 1)
          else return () 

outsideHeapBody wd pt =
	do b <- getBP wd
	   hb <- (getHEntry wd (b + oHeap))
	   te <- (readArray (trail wd) (pt))
	   return ((deref1 hb) < (dereft te))

outsideStackBody wd pt =
	do b <- getBP wd
	   te <- readArray (trail wd) (pt)
	   tt <- readIORef $ envTop wd 
	   return (((dereft te) < b) && ((dereft te) < (tt)))

dereft (TE x _) = x

doWAMFail :: (WAMData a) -> IO ()
doWAMFail wd = do dd "FAILING ... " ;
                  bp <- getBP wd
                  nochoice <- noCP wd
                  if not nochoice -- i.e. there is a choice point
                    then do ta <- readIORef $ traceall wd
			    if debug || ta
			       then do ddout ("BACKTRACKING, BP is " ++(show  bp) ++ " ... " )
			       else return ()
                            popCallStackBPINC wd bp 
                            -- ct <- getHEntry wd (bp + oCodeTop)
                            -- setCT wd (derefdebug 15 ct)
                            next <- getHEntry wd (bp + oNext)
                            oldbp <- getHEntry wd (bp + oChoiceCut)
                            setB0P wd (deref1 oldbp)
                            setPC wd (daddr next)
                            return()
                    else do dd "FAIL COMMIT\n"
                            -- maybe popcallstack here?
                            setQueryResult wd False
                            return ()
               where 
                  daddr x = (derefprogref x)

{- precondition - destination of one of these refs must itself be a ref -}
bind :: (WAMData a) -> WAMRef -> WAMRef -> IO ()
bind wd ref1 ref2 =
    do isref1 <- isRef wd ref1
       isref2 <- isRef wd ref2
       if isref1 && (not isref2 || ref2 < ref1)
          then (bind1 wd ref1 ref2)
	      else (bind1 wd ref2 ref1)

{- precond - ref1 is a HREF cell -}
bind1 :: (WAMData a) -> WAMRef -> WAMRef -> IO ()
bind1 wd ref1 ref2 =
    do entrail wd ref1
       setHEntry wd ref1 (buildHRef ref2)
       return()

--
--
--

updateWeights :: (WAMData a) -> RTEntry -> IO ()
updateWeights wd rte = do rt <- readIORef $ randTable wd
                          -- dd ("Updating with " ++ (HistTree.showTree rt) ++"\n")
                          writeIORef (randTable wd) (TableAccounting.updateWeights rt rte)

resetTable wd = writeIORef (randTable wd) (emptyTable 0 lambdaDefault weightScalePowerDefault)

setLambda wd lambda = do (RT (tab,depth,_,s)) <- readIORef (randTable wd)
			 writeIORef (randTable wd) (RT (tab,depth,lambda,s))

setScale wd s = do (RT (tab,depth,l,_)) <- readIORef (randTable wd)
		   writeIORef (randTable wd) (RT (tab,depth,l,s))

setDepth wd d = do (RT (tab,_,l,s)) <- readIORef (randTable wd)
		   writeIORef (randTable wd) (RT (tab,d,l,s))




--
--  Micellaneous (functional) support
--

isVar :: WAMRef -> HEntry -> Bool
isVar x y = (isHRef y) && (getHRef y) == x

getSize :: WAMRef -> UnsignedNum
getSize ( x )= x

--arity (T _ ar _) = ar
--atom (T at _ _) = at

--  *** WAMOPS ***
-- A rule for all WAMOPs is that all writing must be done below the CT pointer
-- vref of -1 means its a register ...


-- XXX - replace direct writing with bind

--- BROKEN UNTIL I FIX REGISTER HANDLING
---  Register handling fixed but still this is broken ...

-- push a reference to the top
set_variable' :: (WAMData a) -> WAMRef -> IO ()
set_variable' wd val = setVar wd val val

-- True WAMOPS hereafter - see WAMATR page 16,17,18

put_structure :: AtomRef -> Arity -> RegisterRaw -> (WAMData a) -> IO ()
put_structure at ar vreg wd = 
    do addr <- push wd (buildHFunc at ar)
       setRegister wd vreg (buildHRef addr)
       return ()

-- push a reference to the top
set_variable :: RegisterRaw -> (WAMData a) -> IO ()
set_variable reg wd = 
    do ht <- getHT wd
       push wd (buildHRef ht)
       setRegister wd reg (buildHRef ht)
       return ()
                         
-- set a reference to vref
set_value :: RegisterRaw -> (WAMData a) -> IO ()
set_value reg wd = 
    do cont <- getRegister wd reg
       push wd cont
       return ()

put_variable :: RegisterRaw -> RegisterRaw -> (WAMData a) -> IO ()
put_variable reg argreg wd =
    do newref <- pushVariable wd
       setRegister wd reg (buildHRef newref)
       setRegister wd argreg (buildHRef newref)
       return ()
       
put_value :: RegisterRaw -> RegisterRaw -> (WAMData a) -> IO ()
put_value reg argreg wd =
    do cont <- getRegister wd reg
       setRegister wd argreg cont
       return ()

get_variable :: RegisterRaw -> RegisterRaw -> (WAMData a) -> IO ()
get_variable reg argreg wd =
    do cont <- getRegister wd argreg
       setRegister wd reg cont
       return ()

get_value :: RegisterRaw -> RegisterRaw -> (WAMData a) -> IO ()
get_value reg argreg wd = 
    do ar1 <- getRegister wd reg
       ar2 <- getRegister wd argreg
       unify wd (deref1 ar1) (deref1 ar2)
       return ()

get_structure :: AtomRef -> Arity -> RegisterRaw -> (WAMData a) -> IO ()
get_structure at ar reg' wd =
    do regcont <- getRegister wd reg'
       {-if (isHRef regcont)
          then-} 
       let {!reg = getHRef regcont;}
	   in do {addr <- deref wd reg;
		  entry <- getHEntry wd addr;
    		  case entry of
		  e | (isHRef e) -> do currtop <- getHT wd;
		                       push wd (buildHFunc at ar);
		                       bind wd addr currtop;
		                       setWriteMode wd;
		                       return ()
		    | (isHFunc e) -> if ((fromIntegral at) == (fst $ getHFunc e)) 
					    && (ar == (snd $ getHFunc e))
		                         then do setReadMode wd;  
		                                 setSR wd (addr + 1)
		                                 return ()
		                         else do doWAMFail wd
						 return ()
		    | otherwise -> fail "Get Structure: SHOULD NOT BE REACHED!!!\n"}

          {-else fail ("NON REFERENCE IN REGISTER " ++ (show reg') ++ "; contents are " ++ (show regcont) ++ "\n") -}

-- put_structure' wd at ar addr;   -- bind in here ...

unify_variable :: RegisterRaw -> (WAMData a) -> IO ()
unify_variable reg wd =
   do 
      readmode <- isReadMode wd 
      sreg <- getSR wd
      if readmode
         then do inst <- getHEntry wd sreg
                 setRegister wd reg inst
         else do newref <- pushVariable wd
                 setRegister wd reg (buildHRef newref)
      setSR wd (sreg + 1)
      return () -- add S register manipulation


unify_value :: RegisterRaw -> (WAMData a) -> IO ()
unify_value reg wd = 
         do cond <- isReadMode wd
            sreg <- getSR wd
            if cond
               then do reg' <- getRegister wd reg
                       unify wd (derefdebug 1 reg') sreg
                       return ()
               else do cont <- getRegister wd reg
                       push wd cont
                       return ()
            setSR wd (sreg + 1)

-- recursively bind

unify :: (WAMData a) -> WAMRef -> WAMRef -> IO ()
unify wd r1 r2 = 
              do res <- (unify_tf wd r1 r2)
                 if res
                    then return ()
                    else doWAMFail wd

unify_tf :: (WAMData a) -> WAMRef -> WAMRef -> IO Bool
unify_tf wd ref1 ref2 = 
	   do d1 <- deref wd ref1
	      d2 <- deref wd ref2
	      dd ("args are to " ++ (show ref1) ++ " and " ++ (show ref2) ++ "\n")
	      cont1 <- getHEntry wd d1
	      cont2 <- getHEntry wd d2
	      u1 wd d1 d2 cont1 cont2
	      
u1 wd d1 d2 cont1 cont2
	     | d1 == d2 = return True
         | isVar d1 cont1 || isVar d2 cont2 = do bind wd d1 d2
                                                 return True
u1 wd d1 d2 cont1 cont2
         | (isHFunc cont1) && (cont1 == cont2) = unify_k wd (snd $ getHFunc cont1) (d1+1) (d2+1)
u1 wd _ _ _ _ = return False

unify_k :: (WAMData a) -> Arity -> WAMRef -> WAMRef -> IO Bool
unify_k _ 0 _ _ = return True
unify_k wd k r1 r2 =  
    do res <- unify_tf wd r1 r2
       if res
          then unify_k wd (k-1) (r1+1) (r2+1)
          else return False

allocate :: Arity -> (WAMData a) -> IO ()
allocate size wd =
	do oldenv <- getEP wd
	   oldchoice <- getBP wd
	   pc <- getCP wd
	   setEP wd ((min oldenv oldchoice) - fromIntegral (size+2))  -- note this decrements ...
	   top <- getEP wd
	   setHEntry wd (top + 1) (buildHProgRef pc)
	   setHEntry wd (top + 2) (buildHRef oldenv)
	   return ()

-- note no LCO here 
deallocate :: (WAMData a) -> IO ()
deallocate wd =
    do top <- getEP wd
       oldtop <- getHEntry wd (top + 2)
       oldpc <- getHEntry wd (top + 1)
       setEP wd (derefdebug  2 oldtop)
       dd ("Setting CP to " ++ (show oldpc) ++ "\n")
       setPC wd (derefprogref oldpc)
       return ()

call :: AtomRef -> Arity -> (WAMData a) -> IO ()
call at ar wd = 
    do bi <- getBuiltin wd at ar
       if (isJust bi)
          then call_builtin wd (fromJust bi)
          else call_local at ar wd

--
-- Note on b0 register - it only needs to be set on calls; 

call_builtin :: (WAMData a) -> (Builtin a) -> IO ()
call_builtin wd bi = (builtin bi) wd

call_local :: AtomRef -> Arity -> (WAMData a) -> IO ()
call_local at ar wd = 
    do ref <- getCallIndex wd at ar
       if (isJust ref)
         then do contp <- getPC wd
                 setCP wd contp
                 dd ("Contp is" ++ (show contp) ++ "\n")
                 b <- getBP wd
                 setB0P wd b
                 setPC wd ((fromJust ref) - 1)
                 incCallCount wd 
         else do em <- errormsg
                 dd em
                 if exceptOnNoPredicate
                    then fail em
                    else doWAMFail wd
       return ()
    where errormsg = do atstr <- Engine.lookupAtom wd at
		        return ("Calling non-existent predicate " ++ (fromJust atstr) ++ "/" ++ (show ar) ++ "\n")
       
proceed :: (WAMData a) -> IO ()
proceed wd =
    do cp <- getCP wd
       setPC wd cp
       return ()

branch :: WAMRef -> (WAMData a) -> IO ()
branch ref wd = setPC wd (ref - 1)

neck_cut :: (WAMData a) -> IO ()
neck_cut wd = 
    do b <- getBP wd
       b0 <- getB0P wd
       dd ("Neck cut - b is " ++ (show b) ++ " - b0 is - " ++ (show b0) ++ "\n")
       if (b < b0)
         then do setBP wd (deref1 b0)
		 popCallStackBPINC wd (deref1 b0)
                 tidy_trail wd
         else return ()

cut :: RegisterRaw -> WAMData a -> IO ()
cut reg wd =
	do b0 <- getRegister wd reg
	   bp <- getBP wd
	   if (deref1 b0) > bp
	      then do setBP wd (deref1 b0)
		      popCallStackBPINC wd (deref1 b0)
	              tidy_trail wd
	      else return ()
	    
get_level :: RegisterRaw -> WAMData a -> IO ()
get_level reg wd =
    do b0 <- getB0P wd
       setRegister wd reg (buildHRef b0)

--- XXX - XXX - check for correctness of HB!! 
-- still a problem - but HB is only needed for cut, and is effectively sitting in the 
-- last choice point. 

try_here :: Arity -> WAMRef -> ClauseIDRef -> (WAMData a) -> IO ()
try_here size next cid wd =
   do oldenvp <- getEP wd
      oldcontp <- getCP wd
      oldchoicep <- getBP wd
      oldh <- getHT wd
      oldtrail <- getTT wd
      -- oldct <- getOCT wd
      dd ("OLDENVP IS " ++ (show oldenvp) ++ " OLDCHOICEP IS " ++ (show oldchoicep) ++ "\n")
      setBP wd ((min oldenvp oldchoicep) - (fromIntegral size) - oRegStore) 
      bp <- getBP wd
      oldchoicecut <- getB0P wd
      oct <- getOCT wd
      -- oCodeTop is stillborn
      -- ct <- getCT wd
      -- setHEntry wd (bp + oCodeTop) (buildHRef ct)
      dd ("BP is " ++ (show bp) ++ "\n")
      setHEntry wd (bp + oOldCodeTop) (buildHProgRef oct) -- only used in randomized preds
      setHEntry wd (bp + oSize) (buildHRef (fromIntegral size))
      setHEntry wd (bp + oEnvp) (buildHRef oldenvp)
      setHEntry wd (bp + oContp) (buildHProgRef oldcontp)
      setHEntry wd (bp + oChoicep) (buildHRef oldchoicep)
      setHEntry wd (bp + oChoiceCut) (buildHRef oldchoicecut)
      setHEntry wd (bp + oNext) (buildHProgRef next)
      setHEntry wd (bp + oTrail) (buildHTrailRef oldtrail)
      setHEntry wd (bp + oHeap) (buildHRef oldh)
      dd ("STORING " ++ (show $  oldh) ++ " FROM HT\n")
      -- mapM (saveReg wd bp) (restorerange $ fromIntegral size)
      saveRegRange wd bp (fromIntegral size)
      pushCallStack wd cid Try bp
      return ()

{-# INLINE restorerange #-}
restorerange :: Word32 -> [Word32]
restorerange size = if size == 0 
		       then []
		       else [0 .. (size - 1)]

saveRegRange :: (WAMData a) -> WAMRef -> Int -> IO ()
saveRegRange wd bp regid = 
    do if regid < 0
	  then return ()
	  else do cont <- getRegister wd (registerToRaw (ArgRegister (fromIntegral regid)))
		  setHEntry wd (bp + oRegStore + (fromIntegral regid)) cont
		  -- dd ("SAVING CONTENTS OF " ++ (show (ArgRegister regid)) ++ " TO " ++ (show (bp + oRegStore + regid)) ++ "\n")
		  saveRegRange wd bp (regid - 1)

restoreRegRange :: (WAMData a) -> WAMRef -> Int -> IO ()
restoreRegRange wd bp regid = 
    do if regid < 0
	  then return ()
	  else do cont <- getHEntry wd (bp + oRegStore + (fromIntegral regid)) 
		  setRegister wd (registerToRaw $ ArgRegister $fromIntegral  regid) cont
		  -- dd ("RESTORING CONTENTS OF " ++ (show (ArgRegister regid)) ++ " FROM " ++ (show (bp + oRegStore + regid)) ++ "\n")
		  restoreRegRange wd bp (regid - 1)


saveReg :: (WAMData a) -> WAMRef -> UnsignedNum -> IO ()
saveReg wd bp regid = do cont <- getRegister wd (registerToRaw (ArgRegister (fromIntegral regid)))
                         setHEntry wd (bp + oRegStore + regid) cont
                         -- dd ("SAVING CONTENTS OF " ++ (show (ArgRegister regid)) ++ " TO " ++ (show (bp + oRegStore + regid)) ++ "\n")
                         return () 

restoreReg :: (WAMData a) -> WAMRef -> UnsignedNum -> IO ()
restoreReg wd bp regid = do cont <- getHEntry wd (bp + oRegStore + regid) 
                            setRegister wd (registerToRaw $ ArgRegister regid) cont
                            -- dd ("RESTORING CONTENTS OF " ++ (show (ArgRegister regid)) ++ " FROM " ++ (show (bp + oRegStore + regid)) ++ "\n")
                            return () 

try_there :: WAMRef -> Arity -> WAMRef -> ClauseIDRef -> (WAMData a) -> IO ()
try_there there size next cid wd =
   do try_here size next cid wd
      setPC wd there
      return ()

retry_here :: WAMRef -> ClauseIDRef -> (WAMData a) -> IO ()
retry_here next cid wd =
    do dd "RETRYING ..."
       bp <- getBP wd
       size <- getHEntry wd (bp + oSize)
       --- XXX - restore registers
       oldtrailp <- getHEntry wd (bp + oTrail)
       -- tp <- getTT wd
       -- this already set on doWAMFail
       -- ct <- getHEntry wd (bp + oCodeTop)
       -- setCT wd (derefdebug 16 ct)
       unwind_trail wd (derefdebug 3 oldtrailp)
       envp <- getHEntry wd (bp + oEnvp)
       oldcontp <- getHEntry wd (bp + oContp)
       oldh <- getHEntry wd (bp + oHeap)
       -- dd ("T IS " ++ (show $! (derefdebug 4 oldpc)) ++ "\n")
       setEP wd (derefdebug 5 envp)
       setCP wd (derefdebug 10 oldcontp) 
       setHEntry wd (bp + oNext) (buildHProgRef next)
       setTT wd (derefdebug 6 oldtrailp)
       setHT wd (derefdebug 7 oldh)
       dd ("WRITING " ++ (show $ deref1 oldh) ++ " TO HT\n")
       -- mapM (restoreReg wd bp) (restorerange (deref1 size))
       restoreRegRange wd bp (fromIntegral $ deref1 size)
       --oldcs <- getHEntry wd (bp + oCallStack)
       --setCS wd (derefdebug 9 oldcs)
       pushCallStack wd cid Try bp -- will have been popped in the "doWAMFail"
       dd "RETRY DONE\n"
       incCallCount wd 
       return ()

retry_there :: WAMRef -> WAMRef -> ClauseIDRef ->(WAMData a)-> IO ()
retry_there there next cid wd =
   do retry_here next cid wd
      setPC wd there
      return ()

        
trust_here :: ClauseIDRef -> (WAMData a) -> IO () 
trust_here cid wd =
    do dd "TRUSTING ..."
       bp <- getBP wd
       size <- getHEntry wd (bp + oSize)
       --- XXX - restore registers
       oldtrailp <- getHEntry wd (bp + oTrail)
       unwind_trail wd (derefdebug 3 oldtrailp)
       envp <- getHEntry wd (bp + oEnvp)
       oldcontp <- getHEntry wd (bp + oContp)
       oldh <- getHEntry wd (bp + oHeap)
       setEP wd (derefdebug 5 envp)
       setCP wd (derefdebug 10 oldcontp) 
       setTT wd (derefdebug 6 oldtrailp)
       setHT wd (derefdebug 7 oldh)
       dd ("WRITING " ++ (show $ deref1 oldh) ++ " TO HT\n")
       -- mapM (restoreReg wd bp) (restorerange (derefdebug 8 size))
       restoreRegRange wd bp (fromIntegral $ deref1 size)
       oldchoicep <- getHEntry wd (bp + oChoicep)
       setBP wd (derefdebug 11 oldchoicep)       -- incCallCount wd
       pushCallStack wd cid Trust bp -- will have been popped in the "doWAMFail"
       dd "TRUST DONE\n"
       incCallCount wd 
       return ()

trust_there :: WAMRef -> ClauseIDRef -> (WAMData a) -> IO ()
trust_there there cid wd =
   do trust_here cid wd
      setPC wd there
      return ()

randomize_trust_there :: WAMRef -> ClauseIDRef -> (WAMData a) -> IO ()
randomize_trust_there there cid wd =
    do bp <- getBP wd
       newct <- getHEntry wd (bp + oOldCodeTop)
       setCT wd (deref1 newct)
       dd ("POPPING CODE; NEW CT IS " ++ (show $ deref1 newct) ++ "\n")
       trust_there there cid wd


-- pointch = 0 means no switching ...
randomize_try :: Bool -> UnsignedNum -> (WAMData a) -> IO ()
randomize_try weighted size wd = 
    do {start <- getPC wd;
       instrs <- getInstrs wd size (start + size + 1);
       dd ("Instrs are " ++ (show instrs )++ "\n");
       table <- readIORef $ randTable wd;
       history0 <- callRandList wd;
       codetop <- getCT wd;
       pointCh <- readIORef $ pointChange wd;
       origCh <- readIORef $ origChange wd;
       rands <- getRands wd (length instrs);
       let newaddrs = [(codetop) .. (codetop + size - 1)]
	   switch = (length history) + 1 == pointCh; -- lenght hist + 1 == current length looked up in the table
	   history = replacePointChange history0 pointCh origCh
           (newweightedinsts,origcid) = (permuteTry instrs newaddrs table (history) rands switch);
	   newunweightedinsts = permuteUnweighted instrs newaddrs rands;
           newinsts = if weighted
                         then newweightedinsts
                         else newunweightedinsts;  -- REPLACE HERE
       in do {
	     {- cix <- readIORef $ clauseIDIndex wd;
             -- ddout ("New instrs are: " ++ (show (map (\(x,y) -> printCodeEntryInstAux x y cix) newinsts)) ++ " at " ++ (show newaddrs) ++ " HISTORY: " ++ (show history) ++"\n");
	     if pointCh > 0 
	        then ddout ("PointCH " ++ (show pointCh) ++ " origCH " ++ (show (AtomMap.lookupAtom origCh cix)) ++ " SWITCH: " ++ (show switch) ++
			    "\nOld History: " ++ (show (map (\x -> fromJust $ AtomMap.lookupAtom x cix) history0)) ++ 
			    "\nNew History: " ++ (show (map (\x -> fromJust $ AtomMap.lookupAtom x cix) history)) ++"\n") 
                else return (); -}
             pushCodeListRaw wd newinsts;
             dd ("PUSHING CODE; OLD CT IS: " ++ (show codetop) ++ "\n") ;
	     maybe (return ()) (writeIORef $ (origChange wd)) origcid; 
             -- CALL THE JUST PUSHED CODE AND PUT CT IN THE CHOICE POINT
             setOCT wd codetop;
             setCT wd (codetop + size);
             setPC wd (codetop - 1);
	     dd ("SETTING PC TO " ++ (show (codetop - 1)) ++ "\n");
             return ()}}

replacePointChange hist index orig = 
    if index <= (length hist) && index > 0 
       then reverse ((take (index - 1) rhist) ++ (orig:(drop index rhist)))
       else hist
    where rhist = reverse hist

getInstrs :: (WAMData a) -> WAMRef-> WAMRef -> IO [(WAMOpRaw,WAMOpRaw)]
getInstrs wd size end = if size >= 1
                           then do instr <- getCodeEntryAt wd (end - size) 
                                   rest <- getInstrs wd (size-1) end
                                   return (instr:rest)
                           else return []



--
-- Compiler/Execution Driver
--

{- this will be the test code below rehacked -}

{-
untilM :: Monad m => s -> (s -> m Bool) -> (s -> m s) -> m s
untilM s stopP update =
  do stop <- stopP s
  	 if stop
  	 	then return s
  	 	else do s' <- update s
				untilM s' stopP update

execCode wd r =
  untilM wd (\wd -> getCodeEntry wd >>= (/= HaltOP))
            (\wd -> do r' <- execCodeEntry wd r (trace ("Executing code: " ++ (show code)) code) 
	                   incPC wd 1
	                   -- pc <- getPC wd; dd ("PC is now " ++ (show pc) ++ "\n"))
-}


-- Now replaced with C version C is much quicker
#ifdef HASKELL_EXECCODE
-- Debug sections are commented; remove to enable debugging
execCode :: (WAMData a) -> IO ()
execCode wd =
    do incInstCount wd
       code <- getCodeEntryInst wd
#ifdef DEBUG
       ta <- readIORef $ traceall wd
       if debug || ta
	  then do dh wd
	          gic <- getGlobalCount (cInstCount wd)
	          ddout ("GLOBAL INST COUNT IS: " ++ (show gic ) ++ "\n")
	  else return ()
#endif
       ongoing <- getQueryResult wd -- query failure not detected
       if (getop  code) /= op_haltop && ongoing
	  then do cix <- readIORef $ clauseIDIndex wd
	          if not (isauxop code)
		     then do pc <- getPC wd
#ifdef DEBUG
			     dd ("ABOUT TO EXECUTE STD: " ++ (show pc) ++ " : " ++ (show $ printCodeEntryInst code cix) ++ "\n") 
#endif
			     execCodeEntryInst wd code
		     else do codeaux <- getCodeEntryAux wd
			     pc <- getPC wd
#ifdef DEBUG
			     dd ("ABOUT TO EXECUTE AUX: }" ++ (show pc) ++ " : " ++ (show $ printCodeEntryInstAux code codeaux cix) ++ "\n") 
#endif
			     execCodeEntryInstAux wd code codeaux
                  pwd <- newStablePtr wd
		  incPCptr pwd
#ifdef DEBUG
		  if debug || ta
		     then do ddout "Instruction Done\n"
			     briefdump wd
		     else return ()
#endif
	          execCode wd
	  else do dd ("Exiting WAM; state is " ++ (show ongoing) ++ "\n")
	          return ()
#else /* C execCode from CEngine.c */
foreign import ccall "execCode" execCodeptr :: StablePtr (WAMData a) -> PICCount -> PICCount -> IO ()
execCode :: (WAMData a) -> IO ()
execCode wd = do pwd <- newStablePtr wd
                 execCodeptr pwd (cInstCount wd) (cCallCount wd)
#endif



foreign export ccall "execCodeEntryInst" execCodeEntryInstptr :: StablePtr (WAMData a) -> WAMOpRaw -> IO ()

execCodeEntryInstptr :: StablePtr (WAMData a) -> WAMOpRaw -> IO ()
execCodeEntryInstptr pwd op = do wd <- deRefStablePtr pwd
                                 execCodeEntryInst wd op


foreign export ccall "execCodeEntryInstAux" execCodeEntryInstAuxptr :: StablePtr (WAMData a) -> WAMOpRaw -> WAMOpRaw -> IO ()

execCodeEntryInstAuxptr :: StablePtr (WAMData a) -> WAMOpRaw  -> WAMOpRaw -> IO ()
execCodeEntryInstAuxptr pwd op aux = do wd <- deRefStablePtr pwd
                                        execCodeEntryInstAux wd op aux 


-- NEW CALL DISPATCH
execCodeEntryInst :: (WAMData a) -> (WAMOpRaw) -> IO ()
execCodeEntryInst !wd !code = execCodeEntryList1 wd code (getop code)

execCodeEntryList1 !wd !code      {- c | c == op_nullop -} 0x00 = return ();
execCodeEntryList1 !wd !code      {- | c == op_haltop-} 0x01 = fail "Trying to execute a Halt";
execCodeEntryList1 !wd !code      {- | c == op_get_structure -} 0x02 = get_structure (getatomrefinst code) (getarityinst code) ( getreginst1 code) wd;
execCodeEntryList1 !wd !code      {- | c == op_put_structure -} 0x03 = put_structure (getatomrefinst code) (getarityinst code) ( getreginst1 code) wd;
execCodeEntryList1 !wd !code      {- | c == op_unify_value -} 0x04 = unify_value ( getreginst1 code) wd;
execCodeEntryList1 !wd !code      {- | c == op_unify_variable -} 0x05 = unify_variable ( getreginst1 code) wd;
execCodeEntryList1 !wd !code      {- | c == op_allocate -} 0x06 = allocate (getarityinst code) wd;
execCodeEntryList1 !wd !code      {- | c == op_deallocate -} 0x07 = deallocate wd;
execCodeEntryList1 !wd !code      {- | c == op_put_variable -} 0x08 = put_variable ( getreginst1 code) ( getreginst2 code) wd;
execCodeEntryList1 !wd !code      {- | c == op_set_variable -} 0x09 = set_variable ( getreginst1 code) wd;
execCodeEntryList1 !wd !code      {- | c == op_get_variable -} 0x0a = get_variable ( getreginst1 code) ( getreginst2  code) wd;
execCodeEntryList1 !wd !code      {- | c == op_put_value -} 0x0b = put_value ( getreginst1  code) ( getreginst2  code) wd;
execCodeEntryList1 !wd !code      {- | c == op_set_value -} 0x0c = set_value ( getreginst1  code) wd;
execCodeEntryList1 !wd !code      {- | c == op_get_value -} 0x0d = get_value ( getreginst1  code) ( getreginst2  code) wd;
execCodeEntryList1 !wd !code      {- | c == op_call -} 0x0e = call (getatomrefinst code) (getarityinst code) wd;
execCodeEntryList1 !wd !code      {- | c == op_proceed -} 0x0f = proceed wd;
execCodeEntryList1 !wd !code      {- | c == op_neck_cut -} 0x10 = neck_cut wd;
execCodeEntryList1 !wd !code      {- | c == op_cut -} 0x11 = cut ( getreginst1  code) wd;
execCodeEntryList1 !wd !code      {- | c == op_get_level -} 0x12  = get_level ( getreginst1  code) wd;
execCodeEntryList1 !wd !code      {- | c == op_branch -} 0x13 = branch (getwamrefinst code) wd;
execCodeEntryList1 !wd !code      {- | c == op_randomize_try -} 0x14 = randomize_try True (getwamrefinst code) wd
execCodeEntryList1 !wd !code      {- | c == op_randomize_unweighted_try -} 0x15 = randomize_try False (getwamrefinst code) wd
execCodeEntryList1 !wd !code      {- | c == op_rp_trust_here -} 0x16 = fail "no rp trust here";
execCodeEntryList1 !wd !code      {- | c == op_trust_here -} 0x17 = trust_here (getcidinst code) wd;
-- execCodeEntryList1 wd code      _ = fail "Unknown instruction"; 


execCodeEntryInstAux :: (WAMData a) -> (WAMOpRaw) -> WAMOpRaw -> IO ()
execCodeEntryInstAux wd code aux =
    case (getop code) of
    c | c == op_try_here -> try_here (getarityinst code) (getwamrefinst code) (getcidanc aux) wd
      | c == op_retry_here -> retry_here (getwamrefinst code) (getcidanc aux) wd
      | c == op_try_there -> try_there (getwamrefinst code) (getarityinst code) (getwamrefanc1 aux) (getcidanc aux) wd
      | c == op_retry_there -> retry_there (getwamrefinst code) (getwamrefanc1 aux) (getcidanc aux) wd
      | c == op_trust_there -> trust_there (getwamrefinst code) (getcidanc aux) wd
      | c == op_randomize_trust_there -> randomize_trust_there (getwamrefinst code) (getcidanc aux) wd
      | otherwise   -> fail "Unknown Instruction"





{-
= return ()
execCodeEntry wd HaltOP = fail "Trying to execute a Halt"
-}


{-

-- Call dispatch; add new instructions in here
execCodeEntry :: (WAMData a) -> (WAMOp) -> IO ()
-- execCodeEntry wd  NullOP = fail "Trying to execute a NULLOP"
execCodeEntry wd NullOP = return ()
execCodeEntry wd HaltOP = fail "Trying to execute a Halt"

execCodeEntry wd (Get_structure a b c) = get_structure a b c  wd
execCodeEntry wd (Unify_variable a) = unify_variable a  wd
execCodeEntry wd (Unify_value a) = unify_value a  wd
execCodeEntry wd (Allocate a) = allocate a  wd
execCodeEntry wd (Deallocate) = deallocate  wd
execCodeEntry wd (Put_structure at ar reg) = put_structure at ar reg wd
execCodeEntry wd (Set_variable var) = set_variable var wd
execCodeEntry wd (Set_value var) = set_value var wd
execCodeEntry wd (Put_variable reg areg) = put_variable reg areg wd
execCodeEntry wd (Put_value reg areg) = put_value reg areg wd
execCodeEntry wd (Get_variable reg areg) = get_variable reg areg wd
execCodeEntry wd (Get_value reg areg) = get_value reg areg wd
execCodeEntry wd (Call at ar) = call at ar wd
execCodeEntry wd (Proceed) = proceed wd

execCodeEntry wd (Neck_cut) = neck_cut wd
execCodeEntry wd (Cut reg) = cut reg wd
execCodeEntry wd (Get_level reg) = get_level reg wd
execCodeEntry wd (Branch ref) = branch ref wd

execCodeEntry wd (Try_here s n cid) = try_here s n (fromJust $ lookupClauseID wd cid) wd
execCodeEntry wd (Retry_here n cid) = retry_here n (fromJust $ lookupClauseID wd cid) wd
execCodeEntry wd (Trust_here cid) = trust_here (fromJust $ lookupClauseID wd cid) wd

execCodeEntry wd (Randomize_try size) = randomize_try True size wd
execCodeEntry wd (Randomize_unweighted_try size) = randomize_try False size wd

execCodeEntry wd (Randomize_trust_there t cid) = randomize_trust_there t (fromJust $ lookupClauseID wd cid) wd

execCodeEntry wd (Try_there t s n cid) = Engine.try_there t s n (fromJust $ lookupClauseID wd cid) wd
execCodeEntry wd (Retry_there t n cid) = retry_there t n (fromJust $ lookupClauseID wd cid) wd
execCodeEntry wd (Trust_there t cid) = trust_there t (fromJust $ lookupClauseID wd cid) wd

-- execCodeEntry wd (RP_trust_there cid) = rp_trust_here (fromjust $ lookupClauseID wd cid) wd
-- execCodeEntry wd (RP_trust_there t cid) = rp_trust_there t (fromjust $ lookupClauseID wd cid) wd

-}


--
--  --- Testing ---
--

-- Data Dumping --- unsafe!

dumpHeap :: (WAMData a) -> IO String
dumpHeap wd =
    do ele <- getAssocs (heap wd)
       am <- readIORef $ atomIndex wd
       return (blockUp ele 4 am False)
 
blockUp [] _ _ _ = "ENDS\n"
blockUp x k am d0 = str ++ (blockUp (drop k x) k am dots)
	             where (str,dots) = (printelline (take k x) am d0)
 
printelline x am olddots = 
                if all (isHE) x
                   then if olddots
                           then ("",True)
                           else ("...\n",True)
                   else ((foldl (++) "" (map printer x)) ++ "\n",False)
                where isHE (_,x) = isHEmptyAndUninteresting x
                      printer (x,y) = (tabTo (show x) 8) ++ ":" ++ (tabTo (apentry y am) (dumpWidth - 8))

tabTo str n = if length str > n - 1
                 then (take (n-1) str) ++ " "
                 else str ++ (replicate (n - (length str)) ' ')

dumpCode :: (WAMData a) -> IO String
dumpCode wd = 
   do ele <- getElems (code wd)
      return (foldr (++) "ENDS\n" (zipWith (strapp) [0..] (map dc1 ele)))

strapp _ [] = []      
strapp n s = (show n ) ++ ": " ++ s

dc1 x
   -- | x == NullOP = "NullOP\n"
   | x == 0x0 = []
   | otherwise = show x ++ ['\n']


-- Umm - needed but obviously impure
--  To make this unnecessary requires a goodly redesign/rethink
--  ...

ddout :: String -> IO ()
ddout s = do hPutStr stdout s
	     hFlush stdout

-- dd - ST debug
			    
{-# INLINE dd #-}
dd :: String -> IO ()
dd s = if debug
          then putStr s
          else return ()

dh :: (WAMData a) ->IO ()
dh wd = 
    do ta <- readIORef $ traceall wd
       if debugdump || ta
	  then do str <- dumpHeap wd
		  ddout "DUMPING HEAP ...\n"
		  ddout str
		  ddout "REGISTERS:\n"
		  dumpregs wd
		  --ddout "TRAIL:\n"
		  --tr <- getAssocs (trail wd)
		  --ddout ((show $trDump tr) ++ "\n")
		  ddout "HEAP DUMP ENDS\n"
	  else return ()

briefdump wd = 
    do ddout "DUMPING STATE ... "
       ep <- getEP wd
       ddout ("ENVP is " ++ (show ep))
       bp <- getBP wd
       ddout ("  BP is " ++ (show bp))
       ct <- getCT wd
       ddout ("  CT is " ++ (show ct))
       ht <- getHT wd
       ddout ("  HT is " ++ (show ht))
       pc <- getPC wd
       ddout ("  PC is " ++ (show pc) ++ "\n")
       dumpCallStack wd

dumpCallStack wd =
    do cs <- callList wd
       ddout ("Call stack is " ++ (show cs) ++ "\n")
       crl <- callRandList wd
       ddout ("Relevant Call Stack  " ++ (show crl) ++ "\n")

trDump tr = "[" ++ (foldl (\l e -> l ++ (pt e)) [] tr) ++ "]"
    where pt (l,(TE r e)) = ((show l) ++ ":(" ++ (show r) ++ "," ++ (pentry e) ++ "),")
	  pt (_,TEmpty) = ""

dumpregs :: (WAMData a) -> IO ()
dumpregs wd =
    do am <- readIORef $ atomIndex wd
       arg0 <- getRegister wd (registerToRaw $ ArgRegister 0)
       arg1 <- getRegister wd (registerToRaw $ArgRegister 1)
       arg2 <- getRegister wd (registerToRaw $ArgRegister 2)
       arg3 <- getRegister wd (registerToRaw $ArgRegister 3)
       arg4 <- getRegister wd (registerToRaw $ArgRegister 4)
       temp0 <- getRegister wd (registerToRaw $TempRegister 0)
       temp1 <- getRegister wd (registerToRaw $TempRegister 1)
       temp2 <- getRegister wd (registerToRaw $TempRegister 2)
       temp3 <- getRegister wd (registerToRaw $TempRegister 3)
       temp4 <- getRegister wd (registerToRaw $TempRegister 4)
       perm0 <- getRegister wd (registerToRaw $PermRegister 0)
       perm1 <- getRegister wd (registerToRaw $PermRegister 1)
       perm2 <- getRegister wd (registerToRaw $PermRegister 2)
       perm3 <- getRegister wd (registerToRaw $PermRegister 3)
       perm4 <- getRegister wd (registerToRaw $PermRegister 4)
       ddout ("A0: " ++ (asshow arg0 am) ++ " X0: " ++ (asshow temp0 am) ++ " Y0: " ++ (asshow perm0 am) ++ "\n")
       ddout ("A1: " ++ (asshow arg1 am) ++ " X1: " ++ (asshow temp1 am) ++ " Y1: " ++ (asshow perm1 am) ++ "\n")
       ddout ("A2: " ++ (asshow arg2 am) ++ " X2: " ++ (asshow temp2 am) ++ " Y2: " ++ (asshow perm2 am) ++ "\n")
       ddout ("A3: " ++ (asshow arg3 am) ++ " X3: " ++ (asshow temp3 am) ++ " Y2: " ++ (asshow perm3 am) ++ "\n")
       ddout ("A4: " ++ (asshow arg4 am) ++ " X4: " ++ (asshow temp4 am) ++ " Y2: " ++ (asshow perm4 am) ++ "\n")
       return()
    where asshow x am = tabTo (apentry x am) 22

--
-- BUILTINS 
--

--
-- Printer
--

cookedTerms :: (WAMData a) -> [WAMRef] -> IO [Term]
cookedTerms _ [] = return []
cookedTerms wd (arg:args) = 
	  do term <-cookedTerm wd arg
	     rest <- (cookedTerms wd args)
	     return (term:rest)
	    
cookedTerm :: (WAMData a) -> WAMRef -> IO Term
cookedTerm wd start =
    do der <- deref wd start
       cont <- getHEntry wd der
       if (isVar der cont)
          then return (V "VNI" nullpos)
          else do (at,ar) <- gst cont
                  rest <- (cookedTerms wd [ (der + 1) .. (der + (fromIntegral ar)) ])
		  atstr <- Engine.lookupAtom wd (fromIntegral at)
                  return (T (fromJust atstr) ar rest nullpos) 
               where gst hfunc = return (getHFunc hfunc)

cookedArguments :: (WAMData a) -> UnsignedNum -> IO [Term]
cookedArguments wd size =
         do refs <- mapM (munge wd) [0..(size - 1)] -- registers are zero indexed
            cookedTerms wd refs
            -- return []

munge :: (WAMData a) -> UnsignedNum -> IO WAMRef
munge w a = do r <- getRegister w (registerToRaw $ArgRegister a)
               return (derefdebug 13 r) 


--
--  Test hooks
--


{-
compileTermTest :: Term -> IO (STArray a WAMRef HEntry)
compileTermTest t =
          do wd <- emptyWAM stacksize stacksize
             compile_heap_term wd t (-1)
             return (heap wd)
-}

{-
execTest :: [Clause] -> Term -> IO (STArray a WAMRef HEntry)
execTest c t =
	do wd <- compileGoalTest t
	   pushCode wd HaltOP
	   resetRegister wd
	   compile1 wd c
	   code <- (dumpCode wd)
	   dd code
	   execCode wd 0
	   return (heap wd)




testUnify :: [Clause] -> Term -> IO ()
testUnify c t = print $ runSTArray (execTest c t)

-}

-- testGoalCompile :: Term -> IO ()
-- testGoalCompile c = putStr $ runST (compileGoalTest c)

